Исходный код

Option Explicit
Call ImportUsers("TDMS database for test")


'==============================================================================
'Копировать пользователей из указанного приложения в текущее
'==============================================================================
Sub ImportUsers(strAppName)
        Dim Apps, App, AppFrom, User, NewUser, UsersToCopy, DestUsers 

        'Получить коллекцию запущенных приложений
        Set Apps = ThisApplication.Utility.RunTDMSApplications 
        
        'Получить ссылку на приложение с указанным именем strAppName
        Set AppFrom = Nothing 
        For Each App In Apps 
                If StrComp(App.DataBaseName, strAppName) = 0 Then 
                        Set AppFrom = App 
                        Exit For
                End If
        Next 
        
        'Если приложение не найдено, закончить работу
        If AppFrom Is Nothing Then 
                MsgBox "Приложение """ & strAppName & """ не найдено.", vbExclamation
                Exit Sub
        End If
        
        'ПОлучить ссылки на коллекции пользователей обоих приложений
    Set UsersToCopy = AppFrom.Users
    Set DestUsers = ThisApplication.Users
 
         'Копировать пользователей
    For Each User In UsersToCopy
        If Not DestUsers.Has(User.SysName) Then
            Set NewUser = DestUsers.Create
            NewUser.SysName = User.SysName
            NewUser.Description = User.Description
            NewUser.FirstName = User.FirstName
            NewUser.MiddleName = User.MiddleName
            NewUser.LastName = User.LastName
            NewUser.Phone = User.Phone
            NewUser.Mail = User.Mail
            NewUser.AllowLogin = User.AllowLogin
        End If
    Next 
 
End Sub
'==============================================================================